;;; -*- Mode:Lisp; Syntax:ANSI-Common-Lisp; Coding:utf-8 -*-
;;; THE
;;;
;;; Copyright (C) 2011 Alexander Skobelev
;;;
;;; The author grants you the rights to distribute and use this software as
;;; governed by the terms of the Lisp Lesser GNU Public License
;;; (http://opensource.franz.com/preamble.html), known as the LLGPL.


(in-package #:cl-the)

(defparameter *the-skipped-forms* '(THE THE* COERCE QUOTE))

(defun %the-let (type let-form)
  "(let (n (n1 v1) ...) f1 f2 ...) 
=> (the <TYPE> (let (n (n1 (the <TYPE> v1)) ...) (the <TYPE> f1) (the <TYPE> f2) ...))"

  (let ((bindings (cadr let-form))
        (body (cddr let-form))
        (decls '()))
    
    (flet ((proc-binding (binding)
             
             (cond ((atom binding) 
                    (push binding decls) 
                    (if (subtypep type 'number) 
                        `(,binding ,(%the type 0)) 
                        binding))
                   
                   (t  
                    (push (car binding) decls)
                    (list (car binding) (%the type (cadr binding)))))))
    
      
      (setf bindings (mapcar #'proc-binding bindings))
      (when (car decls)
        (setf decls  `(declare (type ,type ,@(reverse decls)))))
      
      (setf body (loop :for form :in body :collect (%the type form)))
      
      (list* (car let-form) bindings decls body))
    ))

;; Helper function
;;------------------------------------------------------------------------------
(defun %the (type form)
  
  (cond 
    ((atom form) 
     (when (and (numberp form) (not (symbolp form)))
       (setf form (coerce form type)))
     `(the ,type ,form))
    
    ((member (car form) *the-skipped-forms*) 
     form)

    ((member (car form) '(let let*)) 
     (%the-let type form))
    
    ((special-operator-p (car form)) 
     `(the ,type ,form))

    ((nth-value 1 (macroexpand-1 form))
     `(the ,type ,form))

    (t 
     (let ((res '()))
       (dolist (item (cdr form))
         (push (%the type item) res))
       `(the ,type (,(car form)  ,@(reverse res)))))))

;; Main macro
;;------------------------------------------------------------------------------
(defmacro the* (type form) 
  "The THE* macro provides basic support for recursive propagating of (THE <TYPE> ...) construction
deep into the FORM body. The main idea is that it should help writing more concise numeric code.

Examples:

  (THE* FLOAT 1) => (THE FLOAT 1.0)

  (THE* FLOAT (+ 1 2)) => (THE FLOAT (+ (THE FLOAT 1.0) (THE FLOAT 2.0)))

  (THE* SINGLE-FLOAT (SIN (/ 1 4))) => 
    (THE SINGLE-FLOAT
      (SIN (THE SINGLE-FLOAT (/ (THE SINGLE-FLOAT 1.0) (THE SINGLE-FLOAT 4.0)))))

  (THE* FLOAT (LET (N (X 1)) (+ 1 N X))) =>
    (LET ((N (THE FLOAT 0.0)) (X (THE FLOAT 1.0)))
      (DECLARE (TYPE FLOAT N X))
      (THE FLOAT (+ (THE FLOAT 1.0) (THE FLOAT N) (THE FLOAT X))))

  (THE* STRING (LET (N (X \"1\")) (CONCATENATE 'STRING N X))) =>
    (LET (N (X (THE STRING \"1\")))
      (DECLARE (TYPE STRING N X))
      (THE STRING (CONCATENATE 'STRING (THE STRING N) (THE STRING X))))
   
  (THE* CHARACTER (LET (X (Y #\\A)) (CHAR/= X Y))) =>
    (LET (X (Y (THE CHARACTER #\a)))
      (DECLARE (TYPE CHARACTER X Y))
      (THE CHARACTER (CHAR/= (THE CHARACTER X) (THE CHARACTER Y))))
"
  (%the type form))

#+the-test
(progn
  (the* float 1)
  (the* float (+ 1 2))
  (the* single-float (sin (/ 1 4)))

  ;; the next two will fail because of NIL in N. How to handle NILs?
  (the* float (let (n (x 1)) (+ (sin (- n 0.5)) 1 n x)))
  (the* string (let (n (x "1")) (concatenate 'string n x)))

  (the* character (let (x (y #\a)) (char/= x y)))
  (the* (unsigned-byte 16) 10000)
)
